home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / PowerLisp 2.01 FAT Folder.sit / PowerLisp 2.01 FAT Folder / PowerLisp 2.01 ƒ / Library / compiler_68k.lisp < prev    next >
Lisp/Scheme  |  1996-06-01  |  57KB  |  2,137 lines
  1. ;;;
  2. ;;;        PowerLisp 2.0
  3. ;;;        Copyright ｩ 1996 Roger Corman.  All rights reserved.
  4. ;;;        68k Compiler source
  5. ;;;
  6.  
  7. ;
  8. ;    Source code for compiler.
  9. ;    This is included in the "COMPILER" package.
  10. ;
  11.  
  12. (eval-when (:compile-toplevel :load-toplevel :execute)
  13.     (provide :compiler)
  14.     (in-package :compiler)
  15.     (require :assembler)
  16.     (use-package :assembler)
  17.     (export '(compiler::compile-top-level-form)))
  18.  
  19. (eval-when (:compile-toplevel :load-toplevel :execute)
  20.     (defun assembly-start (stream char)
  21.         (cons 'compiler::push-assembly-instructions (read-delimited-list #¥] stream)))
  22.     (defun assembly-end (stream char) nil)
  23.     (set-macro-character #¥[ #'assembly-start)
  24.     (set-macro-character #¥] #'assembly-end))
  25.  
  26. ;
  27. ;    We do an eval-when on the entire file so that we get the
  28. ;    performance benefits immediately
  29. ;
  30. (eval-when (:compile-toplevel :load-toplevel :execute)
  31.     
  32. (defvar *assemble-code* t)
  33. (defvar *asm* nil)
  34. (defvar *lex-counter* 0)
  35. (defvar *references* nil)
  36. (defvar *function-name* nil)
  37. (defvar *function-entry-label* nil)
  38. (defvar *cleanup-forms-stack* nil)
  39. (defvar *lambda-list* nil)
  40. (defvar *arg-count* 0)
  41. (defvar *last-call-was-values* nil)
  42. (defvar *returned-multiple-values* nil)
  43. (defvar *environment* nil)
  44. (defvar *embedded-lambdas* nil)
  45. (defvar *lambda-special-vars* nil)
  46. (defvar *lambda-declarations* nil)
  47. (defvar *lambda-special-decs* nil)
  48. (defvar *compile-time-too-mode* nil) 
  49. (defvar *compile-print* nil)
  50. (defvar *compile-output-file* nil)
  51. (defvar *symbol-table* nil)
  52. (defvar *last-call-was-tail-recursion* nil)
  53. (defconstant *jmp_buf-size* 13)            ;; 13 longs are stored
  54.  
  55. ;; top level forms which we will output the names of while compiling
  56. ;; if *compile-print* is true
  57. (defvar *compiler-print-forms* 
  58.     '(defun defmacro defstruct defclass defvar defparameter defconstant))
  59.  
  60. (defun compile-it (name &optional lambda &aux (macro nil))
  61.     (unless (typep name 'symbol) (error "Function name expected"))
  62.     (unless lambda (setf lambda (function-definition (symbol-function name))))
  63.     (setq macro (macro-function name))
  64.     (unless (eq (car lambda) 'lambda) (error "Not a lambda expression"))
  65.     (setq *assemble-code* t)
  66.     (if macro
  67.         (setf (macro-function name) (compile-lambda lambda name))
  68.         (setf (symbol-function name) (compile-lambda lambda name)))
  69.     name)
  70.  
  71. (defun compile-without-assembling-it (name &optional lambda &aux (macro nil))
  72.     (unless (typep name 'symbol) (error "Function name expected"))
  73.     (unless lambda (setf lambda (function-definition (symbol-function name))))
  74.     (setq macro (macro-function name))
  75.     (unless (eq (car lambda) 'lambda) (error "Not a lambda expression"))
  76.     (setq *assemble-code* nil)
  77.     (compile-lambda lambda name))
  78.  
  79. (defun compile-the-file (input-file output-file print)
  80.     (setq *assemble-code* t)
  81.     (do* ((infile (open input-file :direction :input)) 
  82.           (*compile-output-file* 
  83.             (progn 
  84.                 (delete-file output-file) 
  85.                 (open output-file 
  86.                     :direction :output 
  87.                     :if-exists :overwrite
  88.                     :if-does-not-exist :create)))
  89.           (*compile-print* print)
  90.           (*package* *package*)
  91.           (*readtable* *readtable*)
  92.           (*symbol-table* (make-hash-table :size 500))
  93.           (input-expression (read infile nil 'Eof nil) (read infile nil 'Eof nil))
  94.           code
  95.           return-value)
  96.          ((eq input-expression 'Eof) 
  97.             (close infile)
  98.             (set-file-type *compile-output-file* "FASL")
  99.             (close *compile-output-file*)
  100.             output-file)
  101.         
  102.         (process-top-level-forms (list input-expression))))
  103.  
  104. ;;
  105. ;;    The following logic is taken from CLTL2 pp.90-91
  106. ;;
  107. (defun process-top-level-forms (forms &aux code return-value print-form)
  108.     (dolist (f forms)
  109.         (setq print-form nil)
  110.         (if (not (consp f)) (go continue))    ;; no need to process non-list forms
  111.             
  112.         (if (and *compile-print*
  113.                 (member (car f) *compiler-print-forms*) 
  114.                 (consp (cdr f)))
  115.             (setq print-form (list (car f) (cadr f) "...")))
  116.  
  117.         (if (macro-function (car f)) ;; if it is a macro expand it
  118.             (progn
  119.                 (setq f (macroexpand f))
  120.                 (if (not (consp f)) (go continue)))) ;; no need to process non-list forms
  121.  
  122.         ;; watch for some special forms
  123.         (if (special-form-p (car f))
  124.  
  125.             (progn
  126.                 ;; if a progn or locally special form, recurse
  127.                 (if (or (eq (car f) 'common-lisp::progn) 
  128.                         (eq (car f) 'common-lisp::locally))
  129.                     (progn
  130.                         (process-top-level-forms (cdr f))
  131.                         (go continue)))
  132.  
  133.                 ;; if compiler-let, macrolet or symbol-macrolet
  134.                 (if (or (eq (car f) 'common-lisp::compiler-let)
  135.                         (eq (car f) 'common-lisp::macrolet)  
  136.                         (eq (car f) 'common-lisp::symbol-macrolet))
  137.                     (progn
  138.                         (error "Compiler does not support special form: ~A" (car f))
  139.                         (process-top-level-forms (cdr f))
  140.                         (go continue)))
  141.     
  142.                 ;; if eval-when
  143.                 (if (eq (car f) 'common-lisp::eval-when)
  144.                     (progn
  145.                         (compile-top-level-eval-when-form f)
  146.                         (go continue)))))
  147.  
  148.         ;; else it is not a special case
  149.  
  150.         ;; now compile it
  151.         (setq code (compile-top-level-form f))
  152.         (%write-code-to-stream code *compile-output-file* *symbol-table*)
  153.  
  154.         ;; evaluate the form if compile-time-too mode
  155.         (if *compile-time-too-mode*
  156.             (setq return-value (funcall code)))
  157.  
  158. continue
  159.         (if print-form
  160.              (progn
  161.                 (format t "~A~%" print-form)
  162.                 (file-flush)))))
  163.  
  164. (defun compile-top-level-eval-when-form (form)
  165.     (if (or (not (consp form)) (< (length form) 2) (not (listp (cadr form))))
  166.         (error "'eval-when' form missing condition list."))
  167.  
  168.     (let* ((conditions (cadr form))
  169.            (load-condition 
  170.             (or (member 'common-lisp::load conditions) 
  171.                 (member :load-toplevel conditions)))
  172.            (eval-condition 
  173.             (or (member 'common-lisp::eval conditions) 
  174.                 (member :execute conditions)))
  175.            (compile-condition 
  176.             (or (member 'common-lisp::compile conditions) 
  177.                 (member :compile-toplevel conditions))))
  178.  
  179.         (if load-condition
  180.             (if (or compile-condition 
  181.                     (and *compile-time-too-mode* eval-condition))
  182.                 (let ((*compile-time-too-mode* t))
  183.                     (process-top-level-forms (cddr form)))
  184.                 (let ((*compile-time-too-mode* nil))
  185.                     (process-top-level-forms (cddr form))))
  186.  
  187.             ;; load not specified
  188.             (if (or compile-condition 
  189.                     (and *compile-time-too-mode* eval-condition))
  190.                 (eval form)))))            
  191.     
  192. ;;
  193. ;;    The cleanup forms stack needs to be maintained for use in non-local
  194. ;;    lexically scoped exit situations. Specifically, GO with a target outside
  195. ;;    the current construct, and RETURN-FROM when exiting an external construct.
  196. ;;    Note that THROW targets are dynamic, not lexical, and therefore cannot
  197. ;;    be handled at compile time. They are handled via a different mechanism, a
  198. ;    run-time stack. Lexically scoped exits are better handled at compile time,
  199. ;;    both for efficiency (a big concern, because GO is the primary iteration 
  200. ;;    facility) and because the lexical scoping is currently only known at
  201. ;;    compile-time. In other words, a run-time lexical environment is not maintained
  202. ;;    for compiled code, and for efficiency reasons it would be better not to have
  203. ;;    to.
  204. ;;
  205. ;;    Entries on the cleanup forms stack include:
  206. ;;
  207. ;;    (BLOCK block-name block-exit-label)
  208. ;;    (TAGBODY (local-tag-1 . local-label-1) (local-tag-2 . local-label-2) ...)
  209. ;;    (LET (local-var-1 . index1) (local-var-2 . index2) ...)
  210. ;;        (the LET form is used by both LET *and* LET* forms)
  211. ;;    (CATCH catch-tag)
  212. ;;    (UNWIND-PROTECT <compiled code to be included>)
  213. ;; 
  214.  
  215. (defconstant *lambda-list-keywords* 
  216.         '(    &optional 
  217.             &rest 
  218.             &key 
  219.             &aux 
  220.             &allow-other-keys
  221.             &whole
  222.             &body ))
  223.  
  224. ;; the following aren't allowed in lambda function declarations
  225. ;; (only in macros, which will be expanded before we see them)
  226. (defconstant *unsupported-lambda-list-keywords* 
  227.         '(  &whole
  228.             &body ))
  229.  
  230. ;;
  231. ;;    Set up square braces as assembly delimiters for this module
  232. ;;    This helps to clearly distinguish the generated code from the
  233. ;;    surrounding stuff.
  234. ;;
  235. (defun push-assembly-instructions (&rest instructions)
  236.     (dolist (x instructions)
  237.         (push x *asm*)))
  238.  
  239. (defun push-cleanup (x) (push x *cleanup-forms-stack*))
  240. (defun pop-cleanup () (pop *cleanup-forms-stack*))
  241.  
  242. ;;    We use the following registers:
  243. ;;    A0, D0 : scratch registers. D0 ultimately returns the value.
  244. ;;    D3 : stores last returned value
  245. ;;    A2 : used as local index for function call
  246. ;;    A3 : points to lexical storage for the function
  247. ;;    A4 : points to function's environment (variables with indefinite extent)
  248. ;;    A6 : links previous stack frame
  249. ;;    A7 : stack pointer
  250. ;;    A5 : global variables
  251. ;;    
  252. ;;    We do not need to save A5, A6 or A7
  253. ;;    We also don't need to save scratch register D0.
  254. ;;    We *do* need to save A0, A2, A3 and D3.
  255. ;;
  256.             
  257. ;;
  258. ;;    compile-top-level-form (form &optional (assemble t))
  259. ;;    Given an arbitrary lisp form, returns a compiled function 
  260. ;;    equivalent to it.
  261. ;;
  262. (defun compile-top-level-form (form)
  263.     (let* (
  264.            ;; Establish local bindings of these special variables
  265.            ;; so that this function can be entered recursively.
  266.            ;;
  267.            (*asm* nil)
  268.            (*lex-counter* 0)
  269.            (*references* nil)
  270.            (*function-entry-label* (gensym))
  271.            (*last-call-was-values* nil)
  272.            (*returned-multiple-values* nil)
  273.            (*cleanup-forms-stack* nil)
  274.            (*environment* nil)
  275.            (*embedded-lambdas* (find-lambdas form)))    
  276.            
  277.         ;; emit code for function prolog
  278. ;;        [ `(link a6 ,(- (* numargs 4))) ]     ;; this is added at end
  279.         (emit-prolog)
  280.                 
  281.         ;; compile the form
  282.         (compile-form form)
  283.  
  284.         ;; make sure bogus multiple values don't get returned
  285.         (unless *last-call-was-values* (kill-multiple-values))
  286.  
  287.         (emit-epilog)        
  288.         
  289.         ;; if we don't want to assemble it, exit here
  290.         (if *assemble-code* 
  291.             (return (assemble *asm* *references* nil))            
  292.             (return *asm*))))
  293.  
  294.  
  295. ;;---------------------------------------------------
  296. ;;
  297. ;;    compile-lambda (lambda)
  298. ;;    Given a lambda expression, returns a compiled function.
  299. ;;
  300. (defun compile-lambda (lambda func-name)
  301.     (check-lambda lambda)            ;; make sure we can compile it    
  302.     (let* ((*asm* nil)
  303.            (*references* nil)
  304.            (*function-name* func-name)
  305.            (*function-entry-label* (gensym))
  306.            (*cleanup-forms-stack* nil)
  307.            (*lambda-list* (cadr lambda))
  308.            (*last-call-was-values* nil)
  309.            (*returned-multiple-values* nil)
  310.            (*environment* *environment*)    ;; inherit from enclosing expression
  311.            (*embedded-lambdas* (find-lambdas (cdr lambda)))    
  312.            (*arg-count* 0)
  313.            (*lex-counter* 0)
  314.            (*lambda-special-vars* nil)
  315.            (*lambda-declarations* nil)            
  316.            (*lambda-special-decs* nil)
  317.            (*last-call-was-tail-recursion* nil)            
  318.            (forms (cddr lambda))
  319.            (new-vars (collect-new-vars *lambda-list*))
  320.            (lex-vars nil)
  321.            (aux-args (aux-arguments *lambda-list*)))
  322.  
  323.         ;; look for declarations
  324.         (do ((f forms (cdr f)))
  325.             ((null f) (setq forms f))
  326.             (if (and (consp (car f)) (eq (caar f) 'declare))
  327.                 (push (car f) *lambda-declarations*)
  328.                 (progn (setq forms f) (return))))
  329.  
  330.         ;; search declarations for special declarations
  331.         (dolist (declaration *lambda-declarations*)
  332.             (dolist (dec-form (cdr declaration))
  333.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  334.                     (setq *lambda-special-decs*
  335.                         (append (cdr dec-form) *lambda-special-decs*)))))
  336.  
  337.         (setq lex-vars 
  338.             (remove-if 
  339.                 #'(lambda (x) 
  340.                     (or (member x *lambda-special-decs*)
  341.                         (special-variable-p x)))
  342.                 new-vars
  343.                 :key #'car))
  344.  
  345.         (add-lexical-variables lex-vars)
  346.  
  347.         (emit-prolog)
  348.         (compile-lambda-args)
  349.         (create-runtime-bindings)    ;; create necessary heap bindings
  350.         
  351.         ;; handle aux variables by just adding an implicit let* form
  352.         (if aux-args
  353.             (setf forms `((let* ,aux-args ,@forms))))
  354.             
  355.         (compile-nil)        ;; store NIL as default return value
  356.                 
  357.  
  358.         (if *lambda-special-vars*
  359.             (compile-unwind-protect-form 
  360.                 `(unwind-protect 
  361.                     (block ,func-name ,@forms)
  362.                     ($pop-special-bindings ',*lambda-special-vars*)))
  363.  
  364.             ;; else execute the forms directly
  365.             ;; compile the forms as a block
  366.             (compile-block-form `(block ,func-name ,@forms)))
  367.  
  368.         ;; eliminate tail recursion
  369.         (if nil ;; *last-call-was-tail-recursion*
  370.             (let* ((num-call-instructions (- (length *asm*) (length *last-call-was-tail-recursion*)))
  371.                    (call-instructions (reverse (subseq *asm* 0 num-call-instructions)))
  372.                    (find-top-label (gensym))
  373.                    (copy-label))
  374.  
  375.                 ;; strip off the function call
  376.                 (setq *asm* *last-call-was-tail-recursion*)
  377.  
  378.                 ;; push all instructions up to the bsr
  379.                 (do ((inst (pop call-instructions) (pop call-instructions)))
  380.                     ((or (null call-instructions) 
  381.                         (and (consp inst) (eq (car inst) 'assembler::bsr))))
  382.                     (push inst *asm*))
  383.  
  384.                 ;; move passed params to outer stack frame
  385.                 ;; add return address and branch instruction to simulate jsr
  386.                 [
  387.                     `(move.l a7 a3)
  388.                     
  389.                     ;; position a3 above top of parameter frame
  390.                     find-top-label        
  391.                     `(tst.l (a3+))
  392.                     `(bne ,find-top-label)
  393.  
  394.                     ;; copy parameters
  395.                     copy-label
  396.                     `(move.l (-a3) (-a2))
  397.                     `(move.l a3 d0)            ;; haven't implemented cmpa.l instruction yet
  398.                     `(cmp.l a7 d0)
  399.                     `(bne ,copy-label)
  400.                     `(unlk a6)
  401.                     `(move.l (a7) a0)            ; get return address in a0
  402.                     `(lea (a2 4) a7)
  403.                     `(move.l a7 (-a7))
  404.                     `(move.l a0 (-a7))
  405.                     `(bra ,*function-entry-label*)
  406.                 ]
  407.                 
  408.                 ;; add the rest of the instructions
  409.                 (do ((inst (pop call-instructions) (pop call-instructions)))
  410.                     ((null call-instructions)) 
  411.                     (push inst *asm*))))
  412.                 
  413.         ;; make sure bogus multiple values don't get returned
  414.         (unless (or *last-call-was-values* *returned-multiple-values*)
  415.             (kill-multiple-values))
  416.  
  417.         (emit-epilog)
  418.         (pop-cleanup)        
  419.         (if *assemble-code* 
  420.             (return (assemble *asm* *references* nil))            
  421.             (return *asm*))))
  422.  
  423.  
  424. (defun compile-lambda-args ()
  425.     (compile-lambda-required-args)
  426.     (compile-lambda-optional-args)
  427.     (compile-lambda-rest-args)        
  428.     (check-no-more-args)
  429.     (compile-lambda-key-args))
  430.     
  431.  
  432. (defun collect-new-vars (lambda-list)
  433.     (let ((new-vars nil)(supplied_p_vars nil))
  434.         (dolist (n lambda-list)                    ;; add lexical vars
  435.             (if (not (member n *lambda-list-keywords*))
  436.                 (progn
  437.                     (if (consp n)
  438.                         (progn
  439.                             (if (>= (length n) 3)        ;; get supplied_p symbols
  440.                                 (push (caddr n) supplied_p_vars))
  441.                             (push (cons (car n) *lex-counter*) new-vars))
  442.                         (push (cons n *lex-counter*) new-vars))
  443.                     (incf *lex-counter*))))
  444.         (dolist (n supplied_p_vars)
  445.             (push (cons n *lex-counter*) new-vars)    ;; these need to go on the end
  446.             (incf *lex-counter*))
  447.         (nreverse new-vars)))                        
  448.  
  449.  
  450. ;; emit code for start of function            
  451. (defun emit-prolog ()
  452.     [ 
  453.         `(movem.l    a2 a3 a4 d3 (-a7)) 
  454.     ]
  455.  
  456.     (if (or *embedded-lambdas* *environment*)
  457.     [
  458.         `(bsr 2)                        ; push current pc on stack
  459.         `(move.l (a7+) a4)                ; a4 = pc
  460.         `(move.l (a4 -16) a4)            ; a4 = pointer to environment (just before code)
  461.         
  462.     ])
  463.     
  464.     [
  465.         `(movea.l (a6 8) a2)            ; a2 = a6 + 8 = parameter block
  466.         `(lea (a7 16) a3)                ; a3 = pointer to local arguments
  467.                                         ; the offset to a7 should be 4 * number of
  468.                                         ; registers saved!
  469.     ])
  470.  
  471.  
  472. ;; emit code for end of function            
  473. (defun emit-epilog ()
  474.     [
  475.         `(move.l d3 a0)
  476.         `(movem.l (a6 ,(- -16 (* *lex-counter* 4))) a2 a3 a4 d3)
  477.         `(unlk a6)                        ; unlink frame pointer
  478.         `(rts)                            ; d0 already contains return value
  479.     ]
  480.     
  481.     (setq *asm* (nreverse *asm*))
  482.  
  483.     ;; These last instructions get pushed onto the beginning
  484.     ;; of the (now-reversed) instructions. Therefore they are reversed
  485.     ;; here to come out in the right order.
  486.     [
  487.         `(link a6 ,(- (* *lex-counter* 4)))
  488.         *function-entry-label*
  489.     ]    
  490. )
  491.  
  492.  
  493. ;; Make sure there are no more arguments.
  494. (defun check-no-more-args ()
  495.     (if (not (or (rest-arguments *lambda-list*) (key-arguments *lambda-list*)))
  496.         [
  497.             `(move.l (a2+) (-a7))                ; get argument
  498.             `(jsr #'common-lisp::%checkNull)     ; signal error if extra argument
  499.             `(lea (a7 4) a7)                      ; cleanup stack
  500.         ]))
  501.  
  502. ;;
  503. ;;    compile-lambda-required-args
  504. ;;    Generates code to initialize required argumensts.
  505. ;;
  506. (defun compile-lambda-required-args ()
  507.     (dolist (sym (required-arguments *lambda-list*))
  508.         [
  509.             `(move.l (a2+) (-a7))            ; get argument
  510.             `(jsr #'common-lisp::%checkObj) ; signal error if argument missing
  511.             `(lea (a7 4) a7)                  ; cleanup stack
  512.             `(move.l a0 (a3 ,(* *arg-count* 4)))
  513.         ]
  514.         
  515.         (if (or (special-variable-p sym) (member sym *lambda-special-decs*))
  516.             (progn 
  517.                 (push sym *lambda-special-vars*)
  518.                 [
  519.                     `(move.l 0 (-a7))
  520.                     `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  521.                     `(move.l ',sym (-a7))
  522.                     `(move.l a7 (-a7))
  523.                     `(jsr #'common-lisp::$push-special-bindings)
  524.                     `(lea (a7 16) a7)
  525.                 ]))
  526.  
  527.         (incf *arg-count*)))
  528.  
  529.  
  530. ;;
  531. ;;    compile-lambda-optional-args
  532. ;;    Generates code to initialize optional argumensts.
  533. ;;
  534. (defun compile-lambda-optional-args ()
  535.     (dolist (sym (optional-arguments *lambda-list*))
  536.         ;; initialize optional variable
  537.         (let ((else-label (gensym)) 
  538.                 (end-label (gensym)))
  539.             [
  540.                 `(tst.l (a2))                ;; is there an argument
  541.                 `(beq ,else-label)
  542.             ]
  543.             (if (and (consp sym) (>= (length sym) 3))
  544.                 (compile-form `(setq ,(caddr sym) t)))    ;; set supplied_p
  545.             [ 
  546.                 `(move.l (a2+) (a3 ,(* *arg-count* 4)))
  547.                 `(bra ,end-label)
  548.                 else-label
  549.             ]
  550.                 
  551.             ;; else do default initialization
  552.  
  553.             (if (and (consp sym) (>= (length sym) 3))
  554.                 (compile-form `(setq ,(caddr sym) nil)))    ;; set supplied_p
  555.  
  556.             (if (and (consp sym) (cdr sym))
  557.                 (progn
  558.                     [
  559.                         `(movem.l    a0 a2 a3 d0 (-a7))
  560.                     ]
  561.                     (compile-form (cadr sym))
  562.                     [
  563.                         `(movem.l (a7+) a0 a2 a3 d0)
  564.                         `(move.l d3 (a3 ,(* *arg-count* 4)))
  565.                     ])
  566.                 ;; else
  567.                 [
  568.                     `(move.l 'nil (a3 ,(* *arg-count* 4)))
  569.                 ])
  570.             [
  571.                 end-label
  572.             ])
  573.  
  574.         (if (or (special-variable-p sym) (member sym *lambda-special-decs*))
  575.             (progn 
  576.                 (push sym *lambda-special-vars*)
  577.                 [
  578.                     `(move.l 0 (-a7))
  579.                     `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  580.                     `(move.l ',sym (-a7))
  581.                     `(move.l a7 (-a7))
  582.                     `(jsr #'common-lisp::$push-special-bindings)
  583.                     `(lea (a7 16) a7)
  584.                 ]))
  585.             
  586.         (incf *arg-count*)))
  587.  
  588.  
  589. ;;
  590. ;;    compile-lambda-rest-args
  591. ;;    Generates code to initialize rest arguments.
  592. ;;    We allow more than one.
  593. ;;
  594. (defun compile-lambda-rest-args ()
  595.     (let* ((rest-args (rest-arguments *lambda-list*)))
  596.         (if rest-args
  597.             [
  598.                 `(move.l a2 (-a7))
  599.                 `(jsr #'list)
  600.                 `(lea (a7 4) a7)
  601.             ])
  602.         (dolist (sym rest-args)
  603.             [
  604.                 `(move.l a0 (a3 ,(* *arg-count* 4)))
  605.             ]
  606.         
  607.         (if (or (special-variable-p sym) (member sym *lambda-special-decs*))
  608.                 (progn 
  609.                     (push sym *lambda-special-vars*)
  610.                     [
  611.                         `(move.l 0 (-a7))
  612.                         `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  613.                         `(move.l ',sym (-a7))
  614.                         `(move.l a7 (-a7))
  615.                         `(jsr #'common-lisp::$push-special-bindings)
  616.                         `(lea (a7 16) a7)
  617.                     ]))
  618.  
  619.             (incf *arg-count*))))
  620.  
  621.  
  622. ;;
  623. ;;    compile-lambda-key-args
  624. ;;    Generates code to initialize key argumensts.
  625. ;;
  626. (defun compile-lambda-key-args ()
  627.     (dolist (n (key-arguments *lambda-list*))
  628.         (let* ((loop-label (gensym))
  629.                (exit-label (gensym))
  630.                (not-found-label (gensym))
  631.                lex-var 
  632.                default-init 
  633.                key-symbol)
  634.                         
  635.             (if (consp n)
  636.                 (setq lex-var (car n))
  637.                 (setq lex-var n))
  638.                             
  639.             (if (and (consp n) (cdr n))
  640.                 (setq default-init (cadr n))
  641.                 (setq default-init nil))                        
  642.                     
  643.             (setq key-symbol 
  644.                 (intern (symbol-name lex-var) (find-package :keyword)))
  645.                         
  646.             [
  647.                 `(move.l a2 a0)            ; a0 = current argument location
  648.                 `(move.l ',key-symbol d0)
  649.                 loop-label
  650.                 `(tst.l (a0))            ; make sure there are more arguments
  651.                 `(beq ,not-found-label)
  652.                 `(cmp.l (a0+) d0)
  653.                 `(bne ,loop-label)
  654.                 `(move.l (a0) (-a7))    ; make sure there is another argument
  655.                 `(jsr #'common-lisp::%checkObj)
  656.                 `(lea (a7 4) a7)          ; cleanup stack
  657.                 `(move.l a0 (a3 ,(* *arg-count* 4)))
  658.                 `(bra ,exit-label)
  659.                 not-found-label    
  660.             ]
  661.             (compile-form default-init)
  662.             [
  663.                 `(move.l d3 (a3 ,(* *arg-count* 4)))
  664.                 exit-label
  665.             ]
  666.  
  667.         (if (or (special-variable-p n) (member n *lambda-special-decs*))
  668.                 (progn 
  669.                     (push n *lambda-special-vars*)
  670.                     [
  671.                         `(move.l 0 (-a7))
  672.                         `(move.l (a3 ,(* *arg-count* 4)) (-a7))
  673.                         `(move.l ',n (-a7))
  674.                         `(move.l a7 (-a7))
  675.                         `(jsr #'common-lisp::$push-special-bindings)
  676.                         `(lea (a7 16) a7)
  677.                     ]))
  678.  
  679.             (incf *arg-count*))))
  680.  
  681.  
  682. ;;---------------------------------------------------
  683.  
  684. (defun compile-form (form)
  685.     (setq *last-call-was-values* nil)
  686.     (setq *last-call-was-tail-recursion* nil)
  687.     (cond 
  688.         ((null form) (compile-nil))
  689.         ((symbolp form) (compile-symbol form))
  690.         ((not (consp form))    (compile-literal-form form))
  691.         (t (compile-list-form form))))
  692.  
  693.  
  694. (defun compile-list-form (form)
  695.     (let ((firstobj (car form)))
  696.         (cond 
  697.             ((consp firstobj) (compile-explicit-lambda form))
  698.             ((not (symbolp firstobj))
  699.                 (error "Can't compile form--does not begin with a symbol"))
  700.             ((macro-function firstobj) (compile-form (macroexpand form)))
  701.             ((special-form-p firstobj) (compile-special-form form))
  702.             ((eq firstobj 'common-lisp::values) (compile-values-form form))
  703.             (t (compile-function-call-form form)))))
  704.  
  705.  
  706. (defun compile-special-form (form)
  707.     (case (car form)
  708.         (quote                     (compile-quote-form form)) 
  709.         (if                     (compile-if-form form))
  710.         (tagbody                 (compile-tagbody-form form))
  711.         (go                     (compile-go-tag form))
  712.         (setq                     (compile-setq-form form))
  713.         (block                     (compile-block-form form))
  714.         (return-from             (compile-return-from-form form))
  715.         (progn                     (compile-progn-form form))
  716.         (let                     (compile-let-form form))
  717.         (let*                     (compile-let*-form form))
  718.         (flet                     (compile-flet-form form))
  719.         (labels                 (compile-labels-form form))
  720.         (function                (compile-function-special-form form))
  721.         (catch                    (compile-catch-form form))
  722.         (throw                    (compile-throw-form form))
  723.         (unwind-protect         (compile-unwind-protect-form form))
  724.         (multiple-value-call     (compile-multiple-value-call-form form))
  725.         (eval-when                 (compile-eval-when-form form))
  726.         (multiple-value-prog1     (compile-multiple-value-prog1-form form))
  727.         (the                    (compile-the-form form))
  728.         (declare                nil)
  729.         (otherwise                 (error "Special form not supported: ~A~%" (car form)))))
  730.  
  731.  
  732. (defun compile-explicit-lambda (form)
  733.     (if (not (eq 'lambda (caar form)))
  734.         (error "The first element of the expression: ~A is a list but it
  735.                 isn't a lambda expression~%" (car form)))
  736.     (compile-form `(funcall (function ,(car form)) ,@(cdr form))))
  737.  
  738. (defun compile-symbol (sym)
  739.     (let ((temp (find-lex sym)))        ; check for lexical variable
  740.         (if temp
  741.             (if (integerp (cdr temp))
  742.                 [
  743.                     `(move.l (a3 ,(* (cdr temp) 4)) d3)
  744.                 ]
  745.                 ;; else
  746.                 [
  747.                     `(move.l (a3 ,(* (cadr temp) 4)) a0)
  748.                     `($CDR a0 d3)
  749.                 ])
  750.         ;; else see if it is in the inherited environment
  751.             (if (member sym *environment*)
  752.                 [
  753.                     `(move.l 0 (-a7))
  754.                     `(move.l ',sym (-a7))
  755.                     `(move.l a4 (-a7))
  756.                     `(move.l a7 (-a7))
  757.                     `(jsr #'%environment-get-value)
  758.                     `(lea (a7 16) a7)
  759.                     `(move.l a0 d3)
  760.                 ]
  761.             ;; else assume special variable
  762.                 (compile-function-call-form `(symbol-value ',sym))))))
  763.                 
  764.  
  765. (defun compile-if-form (form)
  766.     (let ((else-label (gensym)) 
  767.           (end-label (gensym))
  768.           (test-form (cadr form))
  769.           (then-form (caddr form))
  770.           (else-form (cdddr form)))
  771.  
  772.         (compile-form test-form)
  773.         [
  774.             `(cmp.l 'nil d3)
  775.             `(beq ,else-label)
  776.         ]
  777.         (compile-form then-form)
  778.         (if (consp else-form)
  779.             [
  780.                 `(bra ,end-label)
  781.             ])
  782.         [
  783.             else-label
  784.         ]
  785.         (if (consp else-form)
  786.             (compile-form (car else-form)))
  787.         [
  788.             end-label
  789.         ]))
  790.  
  791.  
  792. (defun compile-tagbody-form (form)
  793.     (let ((tags nil))
  794.         ;; go through list once collecting tags
  795.         (dolist (n (cdr form))
  796.             (if (or (integerp n) (symbolp n))
  797.                 (push (cons n (gensym)) tags)))
  798.         
  799.         (push-cleanup (cons 'tagbody tags))
  800.  
  801.         (dolist (n (cdr form))
  802.             (if (or (integerp n) (symbolp n))
  803.                 (push (cdr (assoc n tags)) *asm*)
  804.                 ;; else it is a form to be evaluated
  805.                 (compile-form n)))
  806.  
  807.         (pop-cleanup)))
  808.             
  809. (defun compile-go-tag (form)
  810.     (let ((tag (cadr form)))
  811.         (if (not (or (integerp tag) (symbolp tag)))
  812.             (error "Invalid go tag encountered"))
  813.         (if (not (find-go-tag tag))            ;; if the tag is not already defined 
  814.             (error "Tag not defined in this scope"))
  815.  
  816.         ;; peel off cleanup stack
  817.         (let ((dest (find-go-tag-tagbody tag)))
  818.             (dolist (f *cleanup-forms-stack*)
  819.                 (if (eq f dest) (return))        ;; returns from the dolist block
  820.                 (case (car f)
  821.                     (unwind-protect  
  822.                         ;; include cleanup code
  823.                         (let ((cleanup-code (cdr f)))
  824.                             (dolist (n cleanup-code)
  825.                                 (push n *asm*))))
  826.                     (catch
  827.                         ;; remove dynamic catch tag
  828.                         [
  829.                             `(jsr #'common-lisp::%popCatcher)    ;; restore result
  830.                         ]))))
  831.                     
  832.         [
  833.             `(bra ,(cdr (find-go-tag tag)))
  834.         ])) 
  835.  
  836. (defun compile-setq-form (form)
  837.     (do ((f (cdr form) (cddr f)) var val temp)
  838.         ((endp f))
  839.         (setq var (car f))
  840.         (setq val (cadr f))
  841.         (setf temp (find-lex var))    ; check for lexical variable
  842.         (if temp
  843.             (progn
  844.                 (compile-form val)
  845.                 (if (integerp (cdr temp))
  846.                     [
  847.                         `(move.l d3 (a3 ,(* (cdr temp) 4)))
  848.                     ]
  849.                 ;; else
  850.                     [
  851.                         `(move.l (a3 ,(* (cadr temp) 4)) a0)
  852.                         `($SETCDR a0 d3)
  853.                     ]))
  854.         ;; else look in the inherited environment
  855.             (if (member var *environment*)
  856.                 (progn
  857.                     (compile-form val)
  858.                     [
  859.                         `(move.l 0 (-a7))
  860.                         `(move.l d3 (-a7))
  861.                         `(move.l ',var (-a7))
  862.                         `(move.l a4 (-a7))
  863.                         `(move.l a7 (-a7))
  864.                         `(jsr #'%environment-set-value)
  865.                         `(lea (a7 20) a7)
  866.                         `(move.l a0 d3)
  867.                     ])
  868.             ;; else call set function
  869.                 (compile-form `(set ',var ,val))))))
  870.  
  871.  
  872. (defun compile-quote-form (form)
  873.     (compile-literal-form (cadr form)))
  874.  
  875. (defun compile-block-form (form)
  876.     (let ((block-name (cadr form)) 
  877.           (block-forms (cddr form)) 
  878.           (exit-label (gensym)))
  879.         (push-cleanup (list 'block block-name exit-label))
  880.  
  881.         ;; in case an embedded lambda has a (return-from block-name) in it    
  882.         (if (referenced-by-embedded-lambdas block-name)
  883.             (progn (compile-catch-form
  884.                 `(catch ',block-name (progn ,@block-forms)))
  885.                 (warn "had to compile a catch form for a block header: ~A" block-name))
  886.             (dolist (f block-forms)
  887.                 (compile-form f)))
  888.  
  889.         [
  890.             exit-label
  891.         ]
  892.         (pop-cleanup)))
  893.  
  894. (defun compile-return-from-form (form)
  895.     (let ((block-name (cadr form))
  896.           (retval nil)
  897.           temp)
  898.         (if (consp (cddr form))
  899.             (setq retval (caddr form)))
  900.         (if (null block-name)
  901.             (setq temp (find-any-block))
  902.             ;; else
  903.             (setq temp (find-block block-name)))
  904.  
  905.         (if temp
  906.             (progn
  907.                 (compile-form retval)
  908.                 ;; if we are returning multiple values from a block
  909.                 ;; just allow them to be returned from entire lambda
  910.                 ;; since we can't be sure whether they should propogate
  911.                 ;; to the end
  912.                 (if (and (consp retval) (eq (car retval) 'values))
  913.                     (setq *returned-multiple-values* t))) 
  914.             (let ((throw-tag `',block-name) 
  915.                     (throw-form retval)) 
  916.  
  917.                 ;; evaluate the form
  918.                 (compile-form throw-form)
  919.                 [
  920.                     `(move.l d3 (-a7))
  921.                 ]
  922.  
  923.                 ;; evaluate the tag
  924.                 (compile-form throw-tag)
  925.                 [
  926.                     `(move.l d3 (-a7))
  927.                 ]
  928.  
  929.                 ;; peel off cleanup stack
  930.                 (let ((dest temp))
  931.                     (dolist (f *cleanup-forms-stack*)
  932.                         (if (eq f dest) (return))        ;; returns from the dolist block
  933.                         (case (car f)
  934.                             (unwind-protect  
  935.                                 ;; include cleanup code
  936.                                 (let ((cleanup-code (cdr f)))
  937.                                     (dolist (n cleanup-code)
  938.                                         (push n *asm*))))
  939.                             (catch
  940.                                 ;; remove dynamic catch tag
  941.                                 [
  942.                                     `(jsr #'cl::%popCatcher)    ;; restore result
  943.                                 ]))))
  944.  
  945.                 [
  946.                     `(jsr #'%throwException)    ;; call throw handler
  947.                 ]
  948.                 (warn "Block label not found: ~A" block-name)
  949.                 (return)))
  950.  
  951.         ;; peel off cleanup stack
  952.         (let ((dest temp))
  953.             (dolist (f *cleanup-forms-stack*)
  954.                 (if (eq f dest) (return))        ;; returns from the dolist block
  955.                 (case (car f)
  956.                     (unwind-protect  
  957.                         ;; include cleanup code
  958.                         (let ((cleanup-code (cdr f)))
  959.                             (dolist (n cleanup-code)
  960.                                 (push n *asm*))))
  961.                     (catch
  962.                         ;; remove dynamic catch tag
  963.                         [
  964.                             `(jsr #'common-lisp::%popCatcher)    ;; restore result
  965.                         ]))))
  966.  
  967.         [    
  968.             `(bra ,(caddr temp))
  969.         ]))    
  970.  
  971. (defun compile-progn-form (form)
  972.     (let ((progn-forms (cdr form))) 
  973.         (dolist (f progn-forms)
  974.             (compile-form f))))
  975.  
  976. (defun compile-multiple-value-prog1-form (form)
  977.     (let ((progn-forms (cdr form))
  978.           (temp-var1 *lex-counter*)
  979.           (temp-var2 (+ *lex-counter* 1)))
  980.  
  981.         ;; if no forms, nothing to do
  982.         (if (null progn-forms) 
  983.             (return))
  984.  
  985.         ;; if only a single form, just handle as a normal progn
  986.         (if (null (cdr progn-forms))
  987.             (progn
  988.                 (compile-form (car progn-forms))
  989.                 (return)))
  990.  
  991.         ;; make room for temp-vars on stack
  992.         (incf *lex-counter* 2)
  993.         (compile-form (car progn-forms))
  994.  
  995.         ;; store the result form and the multiple-value contents on stack
  996.         [
  997.             `(move.l d3 (a3 ,(* temp-var1 4)))
  998.             `(move.l cl::%multiple-values-address a0)
  999.             `(move.l (a0) (a3 ,(* temp-var2 4)))    ; save result on stack
  1000.         ]
  1001.  
  1002.         ;; compile the remaining forms
  1003.         (setq progn-forms (cdr progn-forms))         
  1004.         (dolist (f progn-forms)
  1005.             (compile-form f))
  1006.  
  1007.         ;; restore the first return value and any multiple values
  1008.         [
  1009.             `(move.l (a3 ,(* temp-var1 4)) d3)
  1010.             `(move.l cl::%multiple-values-address a0)
  1011.             `(move.l (a3 ,(* temp-var2 4)) (a0))
  1012.         ]
  1013.  
  1014.         (setq *last-call-was-values* t)))
  1015.  
  1016. (defun compile-let-form (form)
  1017.     (let* ((local-vars (cadr form)) 
  1018.            (let-forms (cddr form)) 
  1019.            (new-vars nil)
  1020.            (special-vars nil)
  1021.            (declarations nil)
  1022.            (special-decs nil)
  1023.            sym)
  1024.  
  1025.         ;; look for declarations
  1026.         (do ((f let-forms (cdr f)))
  1027.             ((null f) (setq let-forms f))
  1028.             (if (and (consp (car f)) (eq (caar f) 'declare))
  1029.                 (push (car f) declarations)
  1030.                 (progn (setq let-forms f) (return))))
  1031.  
  1032.         ;; search declarations for special declarations
  1033.         (dolist (declaration declarations)
  1034.             (dolist (dec-form (cdr declaration))
  1035.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  1036.                     (setq special-decs (append (cdr dec-form) special-decs)))))
  1037.                     
  1038.         ;; go through variable list evaluating values and assigning to temporary
  1039.         ;; space on the stack
  1040.         (dolist (f local-vars)
  1041.             (unless (or (consp f) (symbolp f)) 
  1042.                 (error "Invalid 'let' variable"))
  1043.             (if (or (symbolp f) (not (consp (cdr f))))
  1044.                 [
  1045.                     `(move.l 'nil (a3 ,(* *lex-counter* 4)))
  1046.                 ]
  1047.                 ;; else
  1048.                 (progn
  1049.                     (compile-form (cadr f))
  1050.                     [
  1051.                         `(move.l d3 (a3 ,(* *lex-counter* 4)))
  1052.                     ]))
  1053.  
  1054.             ;; add the symbol to the list of new symbols
  1055.             (if (consp f) 
  1056.                 (setq sym (car f)) 
  1057.                 (setq sym f)) 
  1058.                 
  1059.             (if (or (special-variable-p sym) (member sym special-decs))
  1060.                 (progn 
  1061.                     (if (null special-vars)     ;; if first one
  1062.                         [
  1063.                             `(move.l 0 (-a7))
  1064.                         ])
  1065.                     (push sym special-vars)
  1066.                     [
  1067.                         `(move.l (a3 ,(* *lex-counter* 4)) (-a7))
  1068.                         `(move.l ',sym (-a7))
  1069.                     ])
  1070.                 ;; else
  1071.                 (push (cons sym *lex-counter*) new-vars))
  1072.  
  1073.             (incf *lex-counter*))
  1074.  
  1075.         ;; add the new variables to the lexical environment
  1076.         (add-lexical-variables new-vars)
  1077.         (create-runtime-bindings)
  1078.         
  1079.         ;; if any special variables are present, add those bindings now
  1080.         (if special-vars
  1081.             (progn
  1082.                 [
  1083.                     `(move.l a7 (-a7))
  1084.                     `(jsr #'common-lisp::$push-special-bindings)
  1085.                     `(lea (a7 ,(* 8 (1+ (length special-vars)))) a7)
  1086.                 ]
  1087.                 (compile-unwind-protect-form 
  1088.                     `(unwind-protect 
  1089.                         (progn ,@let-forms)
  1090.                         ($pop-special-bindings ',special-vars))))
  1091.  
  1092.             ;; else execute the forms directly
  1093.             (dolist (f let-forms)
  1094.                 (compile-form f)))
  1095.         
  1096.         ;; restore old lexical environment
  1097.         (pop-cleanup)))
  1098.  
  1099. (defun compile-let*-form (form)
  1100.     (let* ((local-vars (cadr form)) 
  1101.            (let-forms (cddr form))
  1102.            (special-vars nil)
  1103.            (declarations nil)
  1104.            (special-decs nil)
  1105.            sym
  1106.            (lex-var-count 0))
  1107.  
  1108.         ;; look for declarations
  1109.         (do ((f let-forms (cdr f)))
  1110.             ((null f) (setq let-forms f))
  1111.             (if (and (consp (car f)) (eq (caar f) 'declare))
  1112.                 (push (car f) declarations)
  1113.                 (progn (setq let-forms f) (return))))
  1114.  
  1115.         ;; search declarations for special declarations
  1116.         (dolist (declaration declarations)
  1117.             (dolist (dec-form (cdr declaration))
  1118.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  1119.                     (setq special-decs (append (cdr dec-form) special-decs)))))
  1120.  
  1121.         ;; go through variable list evaluating values and assigning to temporary
  1122.         ;; space on the stack
  1123.         (dolist (f local-vars)
  1124.             (unless (or (consp f) (symbolp f)) 
  1125.                 (error "Invalid 'let' variable: ~A~%" f))
  1126.             (if (or (symbolp f) (not (consp (cdr f))))
  1127.                 [
  1128.                     `(move.l 'nil (a3 ,(* *lex-counter* 4)))
  1129.                 ]
  1130.                 ;; else
  1131.                 (progn
  1132.                     (compile-form (cadr f))
  1133.                     [
  1134.                         `(move.l d3 (a3 ,(* *lex-counter* 4)))
  1135.                     ]))
  1136.  
  1137.             ;; add the symbol to the list of new symbols
  1138.             (if (consp f) 
  1139.                 (setq sym (car f)) 
  1140.                 (setq sym f)) 
  1141.     
  1142.             (if (or (special-variable-p sym) (member sym special-decs))
  1143.                 (progn 
  1144.                     (push sym special-vars)
  1145.                     [
  1146.                         `(move.l 0 (-a7))
  1147.                         `(move.l (a3 ,(* *lex-counter* 4)) (-a7))
  1148.                         `(move.l ',sym (-a7))
  1149.                         `(move.l a7 (-a7))
  1150.                         `(jsr #'common-lisp::$push-special-bindings)
  1151.                         `(lea (a7 16) a7)
  1152.                     ])
  1153.                 ;; else
  1154.                 (progn
  1155.                     (add-lexical-variables (list (cons sym *lex-counter*)))
  1156.                     (incf lex-var-count)))
  1157.  
  1158.             (incf *lex-counter*))
  1159.  
  1160.         (create-runtime-bindings)    
  1161.         
  1162.         ;; if any special variables are present, add those bindings now
  1163.         (if special-vars
  1164.             (compile-unwind-protect-form 
  1165.                 `(unwind-protect 
  1166.                     (progn ,@let-forms)
  1167.                     ($pop-special-bindings ',special-vars)))
  1168.  
  1169.             ;; else execute the forms directly
  1170.             (dolist (f let-forms)
  1171.                 (compile-form f)))
  1172.         
  1173.         ;; restore old lexical environment
  1174.         (dotimes (i lex-var-count)
  1175.             (pop-cleanup))))
  1176.  
  1177. (defun compile-flet-form (form)
  1178.     (let* ((local-funs (cadr form)) 
  1179.            (flet-forms (cddr form)) 
  1180.            (new-funs nil)
  1181.            (declarations nil))
  1182.  
  1183.         ;; look for declarations
  1184.         (do ((f flet-forms (cdr f)))
  1185.             ((null f) (setq flet-forms f))
  1186.             (if (and (consp (car f)) (eq (caar f) 'declare))
  1187.                 (push (car f) declarations)
  1188.                 (progn (setq flet-forms f) (return))))
  1189.  
  1190.         ;; search declarations for special declarations
  1191. #|
  1192.         ;; do we need to deal with special declarations here?  RGC
  1193.         (dolist (declaration declarations)
  1194.             (dolist (dec-form (cdr declaration))
  1195.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  1196.                     (setq special-decs (append (cdr dec-form) special-decs)))))
  1197. |#                    
  1198.         ;; go through function list evaluating values and assigning to temporary
  1199.         ;; space on the stack
  1200.         (dolist (f local-funs)
  1201.             (unless (and (consp f) (consp (cdr f)))
  1202.                 (error "Invalid 'flet' function expression"))
  1203.             (let* ((func-name (car f))
  1204.                    (func-args (cadr f))
  1205.                    (func-forms (cddr f)))
  1206.                 (compile-function-special-form 
  1207.                     `(function (lambda ,func-args (block ,func-name ,@func-forms))))
  1208.                 [
  1209.                     `(move.l d3 (a3 ,(* *lex-counter* 4)))
  1210.                 ]
  1211.  
  1212.                 ;; add the function name to the list of new functions
  1213.                 (push (cons func-name *lex-counter*) new-funs)                
  1214.                 (incf *lex-counter*)))
  1215.  
  1216.         ;; add the new functions to the lexical environment
  1217.         (add-lexical-functions new-funs)
  1218.         (create-runtime-bindings)
  1219.         
  1220.         ;; execute the forms directly
  1221.         (dolist (f flet-forms)
  1222.             (compile-form f))
  1223.         
  1224.         ;; restore old lexical environment
  1225.         (pop-cleanup)))
  1226.  
  1227. (defun compile-labels-form (form)
  1228.     (let* ((local-funs (cadr form)) 
  1229.            (flet-forms (cddr form)) 
  1230.            (new-funs nil)
  1231.            (declarations nil)
  1232.            first-func-position)
  1233.  
  1234.         ;; look for declarations
  1235.         (do ((f flet-forms (cdr f)))
  1236.             ((null f) (setq flet-forms f))
  1237.             (if (and (consp (car f)) (eq (caar f) 'declare))
  1238.                 (push (car f) declarations)
  1239.                 (progn (setq flet-forms f) (return))))
  1240.  
  1241.         ;; search declarations for special declarations
  1242. #|
  1243.         ;; do we need to deal with special declarations here?  RGC
  1244.         (dolist (declaration declarations)
  1245.             (dolist (dec-form (cdr declaration))
  1246.                 (if (and (consp dec-form) (eq (car dec-form) 'special))
  1247.                     (setq special-decs (append (cdr dec-form) special-decs)))))
  1248. |#                    
  1249.         (setq first-func-position *lex-counter*)                    
  1250.         (dolist (f local-funs)
  1251.             (unless (and (consp f) (consp (cdr f)))
  1252.                 (error "Invalid 'labels' function expression"))
  1253.             (let* ((func-name (car f)))
  1254.                 (push (cons func-name *lex-counter*) new-funs)
  1255.                 (add-to-environment func-name)        ;; debug        
  1256.                 (incf *lex-counter*)))
  1257.  
  1258.         ;; add the new functions to the lexical environment
  1259.         (add-lexical-functions (reverse new-funs))
  1260.  
  1261.         ;; go through function list evaluating values and assigning to temporary
  1262.         ;; space on the stack
  1263.         (dolist (f local-funs)
  1264.             (let* ((func-name (car f))
  1265.                    (func-args (cadr f))
  1266.                    (func-forms (cddr f))
  1267.                    (pos (cdr (find func-name new-funs :key #'car))))
  1268.                 (if (consp pos)
  1269.                     (setq pos (car pos)))
  1270.                 (compile-function-special-form 
  1271.                     `(function (lambda ,func-args (block ,func-name ,@func-forms))))
  1272.  
  1273.                 (let ((temp (find-lex-function func-name)))    ; check for lexical function
  1274.                     (if temp
  1275.                         (if (integerp (cdr temp))
  1276.                             [
  1277.                                 `(move.l d3 (a3 ,(* (cdr temp) 4)))
  1278.                             ]
  1279.                             ;; else
  1280.                             [
  1281.                                 `(move.l (a3 ,(* (cadr temp) 4)) a0)
  1282.                                 `(move.l d3 (a0 4))    ;; store in CDR field of binding
  1283.                             ])))))
  1284.  
  1285.         (create-runtime-bindings)
  1286.         
  1287.         ;; execute the forms directly
  1288.         (dolist (f flet-forms)
  1289.             (compile-form f))
  1290.         
  1291.         ;; restore old lexical environment
  1292.         (pop-cleanup)))
  1293.  
  1294. (defun compile-function-special-form (form)
  1295.     (let ((func-form (cadr form)))
  1296.         
  1297.         ;; I don't think this will occur, but just in case, we can't
  1298.         ;; keep a reference to an anonymous function object.
  1299.         (if (functionp func-form)
  1300.             (error "Can't compile expression with anonymous function: ~A~%" form))
  1301.  
  1302.         ;; if a compiled lambda expression
  1303.         (if (and (consp func-form) (eq (car func-form) 'lambda))
  1304.             (let ((name nil)
  1305.                   (first-form (third func-form)))
  1306.                 (if (and (consp first-form) (eq (first first-form) 'block))
  1307.                     (setq name (second (third func-form))))
  1308.  
  1309.                 ;; create a new compiled function
  1310.                 (setq func-form (compile-lambda func-form name))     
  1311.                 [
  1312.                     `(move.l 0 (-a7))
  1313.                     `(move.l ',func-form (-a7))
  1314.                     `(move.l a7 (-a7))
  1315.                     `(jsr #'%copy-compiled-function)
  1316.                     `(lea (a7 12) a7)
  1317.                     `(move.l a0 d3)
  1318.                 ]
  1319.                 (create-runtime-bindings)
  1320.                 (export-environment)
  1321.                 (return)))
  1322.                 
  1323.         (unless (symbolp func-form)
  1324.             (error "function special form: ~%Expected a symbol: ~A~%" func-form))
  1325.  
  1326.         (let ((temp (find-lex-function func-form)))    ; check for lexical function
  1327.             (if temp
  1328.                 (if (integerp (cdr temp))
  1329.                     [
  1330.                         `(move.l (a3 ,(* (cdr temp) 4)) d3)
  1331.                     ]
  1332.                     ;; else
  1333.                     [
  1334.                         `(move.l (a3 ,(* (cadr temp) 4)) a0)
  1335.                         `($CDR a0 d3)
  1336.                     ])
  1337.                 ;; else see if it is in the inherited environment
  1338.                 (if (member func-form *environment*)
  1339.                     (progn
  1340.                         [
  1341.                             `(move.l 0 (-a7))
  1342.                             `(move.l ',func-form (-a7))
  1343.                             `(move.l a4 (-a7))
  1344.                             `(move.l a7 (-a7))
  1345.                             `(jsr #'%environment-get-function)
  1346.                             `(lea (a7 16) a7)
  1347.                             `(move.l a0 d3)
  1348.                         ])
  1349.                         
  1350.                 ;; else assume global function
  1351.                     (compile-function-call-form `(symbol-function ',func-form)))))))
  1352.  
  1353.  
  1354. (defun compile-catch-form (form)
  1355.     (let ((catch-tag (cadr form)) 
  1356.           (catch-forms (cddr form)) 
  1357.           (exit-label (gensym)))
  1358.  
  1359.         (push-cleanup (list 'CATCH catch-tag))
  1360.         
  1361.         ;; evaluate the tag
  1362.         (compile-form catch-tag)
  1363.         
  1364.         ;; make room for jmp-buf on stack (13 * 4 bytes)
  1365.         [
  1366.             `(lea (a7 ,(* *jmp_buf-size* -4)) a7)
  1367.  
  1368.         ;; pushCatcher(tag, jmp_buf)
  1369.             `(move.l a7 (-a7))            ;; push jmp_buf
  1370.             `(move.l d3 (-a7))            ;; push tag
  1371.             `(jsr #'common-lisp::%pushCatcher)
  1372.             `(lea (a7 8) a7)            ;; cleanup stack
  1373.  
  1374.         ;; setjmp(jmp_buf)
  1375.             `(move.l a7 (-a7))            ;; push jmp_buf
  1376.             `(jsr #'common-lisp::%setjmp)
  1377.             `(lea (a7 4) a7)
  1378.         
  1379.         ;; if d0 != 0, we caught an exception
  1380.             `(move.l d0 d3)
  1381.             `(tst.l d0)
  1382.             `(bne ,exit-label) 
  1383.             `(move.l 'nil d3)
  1384.         ]
  1385.         
  1386.         (dolist (f catch-forms)
  1387.             (compile-form f))
  1388.  
  1389.         [
  1390.             exit-label
  1391.         ]
  1392.         
  1393.         (pop-cleanup)
  1394.         
  1395.         ;; popCatcher()
  1396.         [
  1397.             `(lea (a7 ,(* *jmp_buf-size* 4)) a7)        ;; cleanup jmp_buf
  1398.             `(jsr #'common-lisp::%popCatcher)
  1399.         ]))
  1400.         
  1401. (defun compile-throw-form (form)
  1402.     (let ((throw-tag (cadr form)) 
  1403.           (throw-form (caddr form))) 
  1404.  
  1405.         ;; evaluate the form
  1406.         (compile-form throw-form)
  1407.         [
  1408.             `(move.l d3 (-a7))
  1409.         ]
  1410.         
  1411.         ;; evaluate the tag
  1412.         (compile-form throw-tag)
  1413.         [
  1414.             `(move.l d3 (-a7))            
  1415.             `(jsr #'%throwException)    ;; call throw handler
  1416.         ]))
  1417.  
  1418. (defun compile-unwind-protect-form (form)
  1419.     (let ((protected-form (cadr form))
  1420.           (cleanup-forms (cddr form)) 
  1421.           (label1 (gensym))
  1422.           (label2 (gensym)))
  1423.         
  1424.         ;; make room for jmp-buf on stack (13 * 4 bytes)
  1425.         [
  1426.             `(lea (a7 ,(* *jmp_buf-size* -4)) a7)
  1427.  
  1428.             ;; pushCatcher(tag, jmp_buf)
  1429.             `(move.l a7 (-a7))                ;; push jmp_buf
  1430.             `(moveq 0 d0)
  1431.             `(move.l d0 (-a7))                ;; push tag
  1432.             `(jsr #'common-lisp::%pushCatcher)
  1433.             `(lea (a7 8) a7)                ;; cleanup stack
  1434.  
  1435.             ;; setjmp(jmp_buf)
  1436.             `(move.l a7 (-a7))                ;; push jmp_buf
  1437.             `(jsr #'common-lisp::%setjmp)
  1438.             `(lea (a7 4) a7)
  1439.         
  1440.             ;; if d0 != 0, we caught an exception
  1441.             `(move.l d0 d3)
  1442.             `(move.l d0 (-a7))                ;; save result on stack
  1443.             `(tst.l d0)
  1444.             `(bne ,label1)
  1445.         ]
  1446.         
  1447.         ;; generate code for cleanup forms
  1448.         (let ((*asm* nil))
  1449.             [
  1450.                 `(move.l d3 (-a7))            ;; store result
  1451.                 `(move.l common-lisp::%multiple-values-address a0)
  1452.                 `(move.l (a0) (-a7))
  1453.                 `(jsr #'common-lisp::%popCatcher)
  1454.             ]
  1455.             (dolist (f cleanup-forms)
  1456.                 (compile-form f))
  1457.             [
  1458.                 `(move.l common-lisp::%multiple-values-address a0)
  1459.                 `(move.l (a7+) (a0))
  1460.                 `(move.l (a7+) d3)            ;; retrieve result
  1461.             ]
  1462.             (setq *asm* (nreverse *asm*))
  1463.             (push-cleanup (cons 'UNWIND-PROTECT *asm*))) 
  1464.         
  1465.         ;; compile protected form
  1466.         (compile-form protected-form)
  1467.  
  1468.         [
  1469.             label1
  1470.         ]
  1471.         
  1472.         ;; include cleanup code
  1473.         (let ((cleanup-code (cdr (pop-cleanup))))
  1474.             (dolist (n cleanup-code)
  1475.                 (push n *asm*)))
  1476.                 
  1477.         ;; retrieve exception result
  1478.         [
  1479.             `(move.l (a7+) a0)
  1480.             `(tst.l a0)
  1481.             `(beq ,label2)
  1482.  
  1483.             ;; continue thrown exception
  1484.             `(move.l a0 (-a7))
  1485.             `(jsr #'common-lisp::%continueException)
  1486.             label2
  1487.             `(lea (a7 ,(* *jmp_buf-size* 4)) a7)        ;; cleanup jmp_buf
  1488.         ]))
  1489.  
  1490. ;; for non toplevel eval-when forms
  1491. (defun compile-eval-when-form (form)
  1492.     (if (or (not (consp form)) (< (length form) 2) (not (listp (cadr form))))
  1493.         (error "'eval-when' form missing condition list."))
  1494.  
  1495.     (let* ((conditions (cadr form)))
  1496.         (if (or (member 'common-lisp::eval conditions) 
  1497.                 (member :execute conditions))
  1498.             (compile-progn-form (cons 'common-lisp::progn (cddr form)))
  1499.             (compile-nil))))    
  1500.  
  1501. (defun compile-multiple-value-call-form (form)
  1502.     (let* ((func (cadr form))
  1503.            (forms (cddr form))
  1504.            (numforms (length forms))
  1505.            (stackframe (* 4 (1+ numforms)))
  1506.            (counter 0)
  1507.            temp)
  1508.         (compile-form func)
  1509.         [
  1510.             `(move.l d3 (-a7))                ; push function address on stack
  1511.             `(lea (a7 ,(- stackframe)) a7)
  1512.         ]
  1513.         (dolist (p forms)                    ; execute each form
  1514.             (compile-form p)
  1515.             [
  1516.                 `($IFELSE 
  1517.                     (
  1518.                         (tst.l (common-lisp::%multiple-values-address))
  1519.                     )
  1520.                     (
  1521.                         ;; if no multiple values, just list the single value
  1522.                         (move.l 0 (-a7))
  1523.                         (move.l 'nil (-a7))
  1524.                         (move.l d3 (-a7))
  1525.                         (move.l a7 (-a7))
  1526.                         (jsr #'cons)
  1527.                         (lea (a7 16) a7)
  1528.                         (move.l a0 d3)
  1529.                     )
  1530.                     (
  1531.                         ;; otherwise get the list of values
  1532.                         (move.l (common-lisp::%multiple-values-address) d3)
  1533.                     ))    
  1534.                         
  1535.                 `(move.l d3 (a7 ,(* counter 4)))
  1536.             ]
  1537.             (incf counter))
  1538.         
  1539.         ;; concatenate all the lists together and store in d3
  1540.         [
  1541.             `(clr.l (a7 ,(* counter 4)))
  1542.             `(move.l a7 (-a7))            ; pass address of params to function
  1543.             `(jsr #'append)
  1544.             `(move.l a0 d3)
  1545.             `(lea (a7 ,(+ 4 stackframe)) a7)            
  1546.         ]
  1547.  
  1548.         ;; now apply the passed function to the resulting value list
  1549.         [
  1550.             `(move.l (a7+) a0)            ; a0 = function address
  1551.             `(move.l 0 (-a7))
  1552.             `(move.l d3 (-a7))            ; argument list
  1553.             `(move.l a0 (-a7))            ; function
  1554.             `(move.l a7 (-a7))            ; pass address of params to function
  1555.             `(jsr #'apply)
  1556.             `(move.l a0 d3)
  1557.             `(lea (a7 16) a7)            
  1558.         ]))
  1559.  
  1560. (defun compile-the-form (form)
  1561.     (let ((type (cadr form))
  1562.           (expr (caddr form)))
  1563.         (compile-form expr)))
  1564.  
  1565. (defun compile-values-form (form)
  1566.     (compile-function-call-form form)
  1567.     (setq *last-call-was-values* t))
  1568.     
  1569. (defun compile-function-call-form (form)
  1570.  
  1571. #|
  1572.     ;; print warning message if function hasn't been defined yet
  1573.     (if (not (functionp (symbol-function (car form))))
  1574.         (format t "Warning: function ~A missing definition~%" (car form)))
  1575. |#
  1576.     (if (or (find-lex-function (car form)) (member (car form) *environment*))
  1577.         (progn
  1578.             (compile-function-call-form `(funcall (function ,(car form)) ,@(cdr form)))
  1579.             (return)))
  1580.  
  1581.     (let* ((numparams (1- (length form)))
  1582.            (stackframe (* 4 (1+ numparams)))
  1583.            (func (car form))
  1584.            (funcparams (cdr form))
  1585.            (counter 0)
  1586.            (tail-recursive (if (eq func *function-name*) *asm*))
  1587.            temp)
  1588.         [
  1589.             `(lea (a7 ,(- stackframe)) a7)
  1590.         ]
  1591.         (dolist (p funcparams)                ; get parameters for function call
  1592.             (setf temp (find-lex p))        ; check for lexical variable
  1593.             (if temp
  1594.                 (if (integerp (cdr temp))
  1595.                     [
  1596.                         `(move.l (a3 ,(* (cdr temp) 4)) (a7 ,(* counter 4)))
  1597.                     ]
  1598.                     ;; else
  1599.                     [
  1600.                         `(move.l (a3 ,(* (cadr temp) 4)) a0)
  1601.                         `($CDR a0 (a7 ,(* counter 4)))
  1602.                     ])
  1603.                 ;; else
  1604.                 (progn 
  1605.                     (compile-form p)    ; ignore multiple values in params
  1606.                     [
  1607.                         `(move.l d3 (a7 ,(* counter 4)))
  1608.                     ]))
  1609.             (incf counter))
  1610.         
  1611.         ;; clear the last position to zero
  1612.         [
  1613.             `(clr.l (a7 ,(* counter 4)))
  1614.             `(move.l a7 (-a7))                ; pass address of params to function
  1615.         ]
  1616.         
  1617.         ;; if it is a recursive call to this function, we need to handle it specially
  1618.         (if (eq func *function-name*)
  1619.             [
  1620.                 `(bsr ,*function-entry-label*)
  1621.             ]
  1622.         ;; else
  1623.             (progn
  1624.                 [
  1625.                     `(jsr #',func)
  1626.                 ]))
  1627.         
  1628.         [
  1629.             `(move.l a0 d3)    
  1630.             `(lea (a7 ,(+ 4 stackframe)) a7)     ;; clean up stack
  1631.         ]
  1632.  
  1633.         ;; flag tail recursion
  1634.         (setq *last-call-was-tail-recursion* tail-recursive)))
  1635.  
  1636. (defun compile-integer (form)
  1637.     (if (typep form 'bignum)
  1638.         (compile-bignum form)
  1639.         [
  1640.             `(move.l ,form (-a7))
  1641.             `(jsr #'common-lisp::%integerAtom)
  1642.             `(lea (a7 4) a7)
  1643.             `(move.l a0 d3)
  1644.         ]))
  1645.  
  1646. (defun compile-bignum (num)
  1647.   (let* ((numcells (cl::%bignum-cells num))
  1648.          (length-flag (if (minusp num) (- numcells) numcells)))
  1649.  
  1650.     ;; allocate room for the data
  1651.     [
  1652.         `(lea (a7 ,(- (* (1+ numcells) 4))) a7)
  1653.         `(move.l a7 a0)
  1654.         `(move.l ,length-flag (a0+))
  1655.     ]
  1656.     (dotimes (i numcells)
  1657.         [
  1658.             `(move.l ,(cl::%bignum-cell num i) (a0+))
  1659.         ])
  1660.         
  1661.     ;; now push the address of this data on the stack and create a bignum
  1662.     [
  1663.         `(move.l a7 (-a7))
  1664.         `(jsr #'cl::%bignumAtomFromLongs)
  1665.         `(lea (a7 ,(+ 8 (* 4 numcells))) a7)
  1666.         `(move.l a0 d3)
  1667.     ]))
  1668.  
  1669. (defun string-int-with-pad (string index)
  1670.     (if (>= index (length string))
  1671.         0
  1672.         (char-int (elt string index))))
  1673.     
  1674. (defun compile-string (string)
  1675.   (let* ((numchars (+ 1 (length string)))
  1676.           n
  1677.           temp
  1678.           (num-longs (truncate (+ 3 numchars) 4)))
  1679.  
  1680.     ;; allocate room for the string
  1681.     [
  1682.         `(lea (a7 ,(- (* num-longs 4))) a7)
  1683.         `(move.l a7 a0)
  1684.     ]
  1685.     (dotimes (i num-longs)
  1686.         (setq temp (* i 4))
  1687.  
  1688.         ;; gather four characters into a long
  1689.         (setq n
  1690.             (+
  1691.                 (* (string-int-with-pad string temp) #x1000000)
  1692.                 (* (string-int-with-pad string (+ temp 1)) #x10000)
  1693.                 (* (string-int-with-pad string (+ temp 2)) #x100)
  1694.                 (string-int-with-pad string (+ temp 3))))
  1695.         [
  1696.             `(move.l ,n (a0+))
  1697.         ])
  1698.         
  1699.     ;; now push the address of this string on the stack and create a string
  1700.     [
  1701.         `(move.l a7 (-a7))
  1702.         `(jsr #'common-lisp::%stringAtom)
  1703.         `(lea (a7 ,(+ 4 (* 4 num-longs))) a7)
  1704.         `(move.l a0 d3)
  1705.     ]))
  1706.  
  1707.  
  1708. ;; need to add support for bit-vectors
  1709. (defun compile-literal-form (form)
  1710.     (cond
  1711.         ((symbolp form)        [ `(move.l ',form d3) ])            
  1712.         ((integerp form)     (compile-integer form))
  1713.         ((stringp form)        (compile-string form))
  1714.         ((characterp form)     (compile-character form))
  1715.         ((listp form)         (compile-quoted-list form))
  1716.         ((vectorp form)        (compile-vector form))
  1717.         ((floatp form)        (compile-float form))
  1718.         ((typep form 'ratio)(compile-ratio form))
  1719.         ((typep form 'complex)(compile-complex form))
  1720.         
  1721.         ;; we will have to code a direct reference to the object
  1722.         ;; This won't work if we use 'compile-file'.
  1723.         (t [ `(move.l ',form d3) ])))
  1724.             
  1725. (defun compile-character (form)
  1726.     [
  1727.         `(move.l ,(char-int form) (-a7))
  1728.         `(jsr #'common-lisp::%charAtom)
  1729.         `(lea (a7 4) a7)
  1730.         `(move.l a0 d3)
  1731.     ])
  1732.     
  1733. ;;
  1734. ;;    compile-quoted-list()
  1735. ;;    We catch and save the last form in case we are dealing with
  1736. ;;    a dotted list or dot pair.
  1737. ;;
  1738. (defun compile-quoted-list (form &aux (last-element (cdr (last form))))
  1739.     (setq form (reverse form))
  1740.     (let ((list-length (length form)))
  1741.         [
  1742.             `(move.l 0 (-a7))
  1743.         ]
  1744.         (compile-literal-form last-element)
  1745.         [
  1746.             `(move.l d3 (-a7))
  1747.         ]
  1748.         (dolist (f form)
  1749.             (compile-literal-form f)
  1750.             [
  1751.                 `(move.l d3 (-a7))
  1752.             ])
  1753.         [
  1754.             `(move.l a7 (-a7))
  1755.             `(jsr #'list*)
  1756.             `(lea (a7 ,(+ 12 (* list-length 4))) a7)
  1757.             `(move.l a0 d3)
  1758.         ]))
  1759.  
  1760. ;;
  1761. ;;    compile-vector()
  1762. ;;
  1763. (defun compile-vector (form)
  1764.     (setq form (nreverse (concatenate 'list form)))
  1765.     (let ((list-length (length form)))
  1766.         [
  1767.             `(move.l 0 (-a7))
  1768.         ]
  1769.         (dolist (f form)
  1770.             (compile-literal-form f)
  1771.             [
  1772.                 `(move.l d3 (-a7))
  1773.             ])
  1774.         [
  1775.             `(move.l a7 (-a7))
  1776.             `(jsr #'vector)
  1777.             `(lea (a7 ,(+ 8 (* list-length 4))) a7)
  1778.             `(move.l a0 d3)
  1779.         ]))
  1780.  
  1781. ;; define these in order to get at the binary representation of a floating
  1782. ;; point number so that we can generate the machine code to build it.
  1783. ;; These functions don't check their type, so we get get the data.
  1784.  
  1785. (defasm %fp-upper-32 (x)
  1786. #{
  1787.     ($FUNC-BEGIN 0)
  1788.     (move.l (a0) a0)
  1789.     ($CAR a0)
  1790.     (move.l a0 (-a7))
  1791.     (jsr #'common-lisp::%createInteger)
  1792.     (lea (a7 4) a7)
  1793.     ($RETURN a0)
  1794. })
  1795.  
  1796. (defasm %fp-lower-32 (x)
  1797. #{
  1798.     ($FUNC-BEGIN 0)
  1799.     (move.l (a0) a0)
  1800.     ($CDR a0)
  1801.     (move.l a0 (-a7))
  1802.     (jsr #'common-lisp::%createInteger)
  1803.     (lea (a7 4) a7)
  1804.     ($RETURN a0)
  1805. })
  1806.  
  1807. ;;
  1808. ;;    compile-float()
  1809. ;;
  1810. (defun compile-float (form)
  1811.     [
  1812.         `(move.l ,(%fp-lower-32 form) (-a7))
  1813.         `(move.l ,(%fp-upper-32 form) (-a7))
  1814.         `(jsr #'common-lisp::%floatAtomFromLongs)
  1815.         `(lea (a7 8) a7)
  1816.         `(move.l a0 d3)
  1817.     ])
  1818.  
  1819. ;;
  1820. ;;    compile-ratio()
  1821. ;;
  1822. (defun compile-ratio (form)
  1823.     [
  1824.         `(move.l 0 (-a7))
  1825.     ]
  1826.     (compile-form (denominator form))
  1827.     [
  1828.         `(move.l d3 (-a7))
  1829.     ]    
  1830.     (compile-form (numerator form))
  1831.     [
  1832.         `(move.l d3 (-a7))
  1833.         `(move.l a7 (-a7))
  1834.         `(jsr #'/)
  1835.         `(lea (a7 16) a7)
  1836.         `(move.l a0 d3)
  1837.     ])
  1838.     
  1839. ;;
  1840. ;;    compile-complex()
  1841. ;;
  1842. (defun compile-complex (form)
  1843.     [
  1844.         `(move.l 0 (-a7))
  1845.     ]
  1846.     (compile-form (imagpart form))
  1847.     [
  1848.         `(move.l d3 (-a7))
  1849.     ]    
  1850.     (compile-form (realpart form))
  1851.     [
  1852.         `(move.l d3 (-a7))
  1853.         `(move.l a7 (-a7))
  1854.         `(jsr #'complex)
  1855.         `(lea (a7 16) a7)
  1856.         `(move.l a0 d3)
  1857.     ])
  1858.     
  1859.  
  1860. (defun check-lambda (lambda)
  1861.     (let ((lambda-list (cadr lambda)))
  1862.         (dolist (n lambda-list)
  1863.             (if (member n *unsupported-lambda-list-keywords*)
  1864.                 (error "Can't compile this lambda list keyword: ~A~%" n)))))
  1865.             
  1866.     
  1867. (defun find-lex (var)
  1868.     (let (found)
  1869.         (dolist (n *cleanup-forms-stack* nil)
  1870.             (if (eq (car n) 'LET)
  1871.                 (progn
  1872.                     (setq found (assoc var (cdr n)))
  1873.                     (if found (return-from find-lex found)))))))
  1874.  
  1875. (defun find-lex-function (var)
  1876.     (let (found)
  1877.         (dolist (n *cleanup-forms-stack* nil)
  1878.             (if (eq (car n) 'FLET)
  1879.                 (progn
  1880.                     (setq found (assoc var (cdr n)))
  1881.                     (if found (return-from find-lex-function found)))))))
  1882.  
  1883. (defun find-go-tag (var)
  1884.     (let (found)
  1885.         (dolist (n *cleanup-forms-stack* nil)
  1886.             (if (eq (car n) 'TAGBODY)
  1887.                 (progn
  1888.                     (setq found (assoc var (cdr n)))
  1889.                     (if found (return-from find-go-tag found)))))))
  1890.  
  1891. ;;
  1892. ;;    find-go-tag-tagbody
  1893. ;;    Returns the cleanup form for the TAGBODY block which contains the 
  1894. ;;    passed tag.
  1895. ;;
  1896. (defun find-go-tag-tagbody (var)
  1897.     (let (found)
  1898.         (dolist (n *cleanup-forms-stack* nil)
  1899.             (if (eq (car n) 'TAGBODY)
  1900.                 (progn
  1901.                     (setq found (assoc var (cdr n)))
  1902.                     (if found (return-from find-go-tag-tagbody n)))))))
  1903.  
  1904. (defun find-block (name)
  1905.     (dolist (n *cleanup-forms-stack* nil)
  1906.         (if (eq (car n) 'BLOCK)
  1907.             (if (eq (cadr n) name)
  1908.                 (return-from find-block n)))))
  1909.  
  1910. (defun find-any-block ()
  1911.     (dolist (n *cleanup-forms-stack* nil)
  1912.         (if (eq (car n) 'BLOCK)
  1913.             (return-from find-any-block n))))
  1914.  
  1915. ;;
  1916. ;;    required-arguments
  1917. ;;    Returns a list of the required arguments in a lambda list.
  1918. ;;
  1919. (defun required-arguments (lambda-list)
  1920.     (let ((arglist nil))
  1921.         (dolist (n lambda-list)
  1922.             (if (member n *lambda-list-keywords*)
  1923.                 (return)        ;; exit dolist loop
  1924.                 (push n arglist)))
  1925.         (nreverse arglist)))
  1926.  
  1927. ;;
  1928. ;;    optional-arguments
  1929. ;;    Returns a list of the optional arguments in a lambda list.
  1930. ;;
  1931. (defun optional-arguments (lambda-list)
  1932.     (let ((arglist nil))
  1933.         (dolist (n (cdr (member '&optional lambda-list)))
  1934.             (if (member n *lambda-list-keywords*)
  1935.                 (return)        ;; exit dolist loop
  1936.                 (push n arglist)))
  1937.         (nreverse arglist)))
  1938.  
  1939. ;; we don't need this
  1940. ;;
  1941. ;;(defun get-supplied-p-args (lambda-list)    
  1942. ;;    (let ((args nil) (forms (optional-arguments lambda-list)))
  1943. ;;        (dolist (f forms)
  1944. ;;            (if (>= (length f) 3)
  1945. ;;                (push (list (caddr f) nil) args)))
  1946. ;;        (reverse args)))                
  1947.  
  1948. ;;
  1949. ;;    rest-arguments
  1950. ;;    Returns a list of the rest arguments in a lambda list.
  1951. ;;
  1952. (defun rest-arguments (lambda-list)
  1953.     (let ((arglist nil))
  1954.         (dolist (n (cdr (member '&rest lambda-list)))
  1955.             (if (member n *lambda-list-keywords*)
  1956.                 (return)        ;; exit dolist loop
  1957.                 (push n arglist)))
  1958.         (nreverse arglist)))
  1959.         
  1960. ;;
  1961. ;;    key-arguments
  1962. ;;    Returns a list of the optional key in a lambda list.
  1963. ;;
  1964. (defun key-arguments (lambda-list)
  1965.     (let ((arglist nil))
  1966.         (dolist (n (cdr (member '&key lambda-list)))
  1967.             (if (member n *lambda-list-keywords*)
  1968.                 (return)        ;; exit dolist loop
  1969.                 (push n arglist)))
  1970.         (nreverse arglist)))
  1971.         
  1972. ;;
  1973. ;;    aux-arguments
  1974. ;;    Returns a list of the aux arguments in a lambda list.
  1975. ;;
  1976. (defun aux-arguments (lambda-list)
  1977.     (let ((arglist nil))
  1978.         (dolist (n (cdr (member '&aux lambda-list)))
  1979.             (if (member n *lambda-list-keywords*)
  1980.                 (return)        ;; exit dolist loop
  1981.                 (push n arglist)))
  1982.         (nreverse arglist)))
  1983.         
  1984.  
  1985. ;;
  1986. ;;    kill-multiple-values
  1987. ;;    Use this function to make sure that ignored multiple values don't stick
  1988. ;;    around through successive evaluations.
  1989. ;;
  1990. (defun kill-multiple-values ()
  1991.     [
  1992.         `(clr.l (common-lisp::%multiple-values-address))
  1993.     ])
  1994.  
  1995. (defun compile-nil () 
  1996.     [ `(move.l 'nil d3) ]
  1997.     (setq *last-call-was-values* nil))
  1998.  
  1999. (defun valid-lambda (x)
  2000.     (and (listp x) (> (length x) 2) (eq (car x) 'lambda) (listp (cadr x))))
  2001.  
  2002. (defun find-lambdas (x)
  2003.     (cond ((not (consp x)) nil)
  2004.           ((valid-lambda x) (list x))
  2005.           ((eq (car x) 'FLET) (cadr x))
  2006.           ((eq (car x) 'LABELS) (cadr x))
  2007.           ((eq (car x) 'DEFUN) (list x))
  2008.           ((eq (car x) 'DEFMACRO) (list x))
  2009.           (t (append (find-lambdas (car x)) (find-lambdas (cdr x))))))
  2010.  
  2011. (defun add-lexical-variables (varlist)
  2012.     (push-cleanup (cons 'LET varlist)))
  2013.  
  2014. (defun add-lexical-functions (varlist)
  2015.     (push-cleanup (cons 'FLET varlist)))
  2016.  
  2017. (defun search-lambdas (var lambdas)
  2018.     (cond ((null lambdas) nil)
  2019.           ((eq var lambdas) var)
  2020.           ((atom lambdas) nil)
  2021.           ((search-lambdas var (car lambdas)))
  2022.           ((search-lambdas var (cdr lambdas)))))
  2023.           
  2024. (defun referenced-by-embedded-lambdas (var)
  2025.     (search-lambdas var *embedded-lambdas*))
  2026.     
  2027. (defun create-runtime-bindings ()
  2028.     (if *embedded-lambdas*
  2029.         (dolist (n *cleanup-forms-stack*)
  2030.             (if (or (eq 'LET (car n)) (eq 'FLET (car n)))
  2031.                 (dolist (m (cdr n))
  2032.                     (let* ((sym (car m))
  2033.                            (index (cdr m)))
  2034.                         (if (and (integerp index) 
  2035.                                 (referenced-by-embedded-lambdas sym))
  2036.                             (progn 
  2037.                                 (setf (cdr m) (list index))
  2038.                                 (push sym *environment*)
  2039.                                 [
  2040.                                     ;; add a heap binding for the variable
  2041.                                     `(move.l (a3 ,(* index 4)) (-a7))
  2042.                                     `(move.l ',sym (-a7))
  2043.                                     `(jsr #'cl::%cons)
  2044.                                     `(lea (a7 8) a7)
  2045.                                     `(move.l a0 (a3 ,(* index 4)))
  2046.  
  2047. #|                                    ;; add a heap binding for the variable
  2048.                                     `(move.l 0 (-a7))
  2049.                                     `(move.l (a3 ,(* index 4)) (-a7))
  2050.                                     `(move.l ',sym (-a7))
  2051.                                     `(move.l a7 (-a7))
  2052.                                     `(jsr #'cons)
  2053.                                     `(lea (a7 16) a7)
  2054.                                     `(move.l a0 (a3 ,(* index 4)))
  2055. |#
  2056.                                 ]))))))))
  2057.  
  2058. ;;
  2059. ;;    export-environment()
  2060. ;;    d3 points to the function to receive the environment
  2061. ;;
  2062. (defun export-environment ()
  2063.     ;; first copy our heap environment
  2064.     [
  2065.         `(move.l 0 (-a7))
  2066.         `(move.l a4 (-a7))        ;; our environment
  2067.         `(move.l d3 (-a7))        ;; target function
  2068.         `(move.l a7 (-a7))
  2069.         `(jsr #'%function-environment)    ;; copy it
  2070.         `(lea (a7 16) a7)
  2071.         
  2072.         ;; now get the target environment in a0
  2073.         `(move.l 0 (-a7))
  2074.         `(move.l d3 (-a7))        ;; target function
  2075.         `(move.l a7 (-a7))
  2076.         `(jsr #'%function-environment)    ;; get its environment
  2077.         `(lea (a7 12) a7)        
  2078.     ]
  2079.     
  2080.     ;; now add all our current heap bindings
  2081.     (if *embedded-lambdas*
  2082.         (dolist (n *cleanup-forms-stack*)
  2083.             (if (eq 'LET (car n))
  2084.                 (dolist (m (cdr n))
  2085.                     (let* ((sym (car m)) 
  2086.                            (index (cdr m)))
  2087.                         (if (consp index)
  2088.                             [
  2089.                                 ;; add the binding to the target environment
  2090.                                 `(move.l a0 (-a7))
  2091.                                 `(move.l 0 (-a7))
  2092.                                 `(move.l (a3 ,(* (car index) 4)) (-a7))
  2093.                                 `(move.l a0 (-a7))
  2094.                                 `(move.l a7 (-a7))
  2095.                                 `(jsr #'%environment-add-binding)
  2096.                                 `(lea (a7 16) a7)
  2097.                                 `(move.l (a7+) a0)
  2098.                             ]))))))
  2099.     (if *embedded-lambdas*
  2100.         (dolist (n *cleanup-forms-stack*)
  2101.             (if (eq 'FLET (car n))
  2102.                 (dolist (m (cdr n))
  2103.                     (let* ((sym (car m)) 
  2104.                            (index (cdr m)))
  2105.                         (if (consp index)
  2106.                             [
  2107.                                 ;; add the binding to the target environment
  2108.                                 `(move.l a0 (-a7))
  2109.                                 `(move.l 0 (-a7))
  2110.                                 `(move.l (a3 ,(* (car index) 4)) (-a7))
  2111.                                 `(move.l a0 (-a7))
  2112.                                 `(move.l a7 (-a7))
  2113.                                 `(jsr #'%environment-add-function-binding)
  2114.                                 `(lea (a7 16) a7)
  2115.                                 `(move.l (a7+) a0)
  2116.                             ])))))))
  2117.  
  2118. (defun add-to-environment (sym) (push sym *environment*))
  2119. (defun find-in-environment (sym) (member sym *environment*))
  2120. (defun environment-not-empty () *environment* )
  2121.  
  2122. )        ;; close beginning eval-when
  2123.  
  2124.  
  2125.  
  2126.  
  2127.  
  2128.  
  2129.  
  2130.  
  2131.  
  2132.  
  2133.  
  2134.  
  2135.  
  2136.  
  2137.